Internet Info 1994 March

home *** CD-ROM | disk | FTP | other *** search

/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / c / hp8krc.bas < prev next >

Wrap

BASIC Source File | 1990-01-31 | 49.6 KB | 870 lines

10 ! **************************************************************** ! 20 ! * * ! 30 ! * KERMIT DATA TRANSFER PROGRAM FOR THE HP86 MICROCOMPUTER * ! 35 ! * * ! 40 ! * Version 1.01 : Date:- 16 Apr 87 at 11:25 * ! 45 ! * * ! 50 ! * Programmer:- Martin J. Rootes * ! 60 ! * Location :- Computer Services Department, * ! 70 ! * Sheffield City Polytechnic. * ! 80 ! * * ! 90 ! **************************************************************** ! 100 DIM IBUFF$[264],OBUFF$[264] ! Define input & output buffers 105 DIM K$[1],k$[1],I$[256] ! Define string variables 110 DIM CR$[1],LF$[1],ESC$[1],BEL$[1] ! Define control characters 115 DIM EL$[1],BS$[1],DEL$[1],NULL$[1] ! '' '' '' 120 DIM SP$[1] ! Define space 125 INTEGER S1,S2,S3,S4,K,R,C,I,F ! Define integer variables 130 CR$[1]=CHR$ (13) @ LF$=CHR$ (10) ! <CR> & <LF> 135 ESC$[1]=CHR$ (27) @ BEL$=CHR$ (7) ! Escape & bell 140 EL$[1]=CHR$ (154) @ BS$=CHR$ (155) ! Endline & Backspace keys 145 DEL$[1]=CHR$ (127) @ NULL$=CHR$ (0) ! Delete & Null 150 SP$=" " ! Space 155 DIM RP$[96],OP$[96],ID$[91],OD$[91] ! Packets 160 DIM S$[256],DB$[256],SF$[17],DF$[40],T$[1],RT$[1],c$[1] ! 165 DIM SI$[1],SH$[1],SD$[1],SE$[1],SB$[1],TM$[1],AK$[1],NK$[1] ! Packet types 170 DIM RQCTL$[1],SQCTL$[1],RPADC$[1],SPADC$[1] ! Prefix & pad 175 DIM MK$[1],SEOL$[1],REOL$[1],CRLF$[4] ! Mark & EOLs 180 INTEGER N,S,T,e,f,i,j,l,m,r,t ! Temp vars 185 INTEGER n,rn,db,tmo,nk,bp,rr,rc,sr,sc ! Parameters 190 INTEGER RMAXL,SMAXL,MAXL,MINL,RTO,STO,RNPAD,SNPAD,REOL,SEOL,TMO,STM,RLIM 195 SI$="S" @ SH$="F" @ SD$="D" @ SE$="Z" @ SB$="B" ! Send packet types 200 AK$="Y" @ NK$="N" @ TM$="T" @ ER$="E" ! Other packet types 205 MK$=CHR$ (1) @ CRLF$="#M#J" ! Mark ^A, <CR><LF> 210 SEOL$,REOL$=CR$ @ RPADC$=NULL$ @ SQCTL$="#" ! EOL's, pad char & prefix 215 RMAXL=94 @ RTO,STO=20 @ RNPAD=0 @ SEOL=13 ! Max len, Timeouts, pad & eol 220 RLIM=10 @ STM=10000 @ rr=17 @ sr=15 @ rc,sc=10 ! Retries, send timeout 225 db=1 ! Debug (ON FOR TESTING) 250 DIM F$[80],CL$[61],CP$[24] 255 CL$="CONNECT, SEND, RECEIVE, SET, SHOW, EXIT, QUIT, CAT" 260 KP$="KERMIT-HP86" @ CP$=KP$ ! Kermit prompt, Command prompt 265 DIM VC$[63],DT$[1],CN$[1],UL$[1],FTYP$[8] ! Dimension variables 270 VC$=".1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ" ! Legal characters 275 DT$="." @ CN$=":" @ UL$="_" @ Q$=CHR$ (34) ! Dot, colon, underline & qoute 280 FTYP$="DATA" ! Default file type 300 ALPHALL @ PAGESIZE 24 @ CLEAR @ R=0 ! Set no of lines (24) 310 DIM EM$(24)[24] ! 320 EM$(0)="Transfer successfull" @ EM$(1)="Timeout receiving" 325 EM$(2)="NAK received" @ EM$(3)="Checksum error" @ EM$(4)="Incorrect packet" 330 EM$(5)="Timeout sending" @ EM$(6)="Cannot rename file" 335 EM$(7)="Disc write protected" @ EM$(8)="*File closed*" 340 EM$(9)="File does not exist" @ EM$(10)="Incorrect file type" 345 EM$(11)="*Random overflow*" @ EM$(12)="Read error" 350 EM$(13)="End of file" @ EM$(14)="Record does not exist" 355 EM$(15)="No M.S. device" @ EM$(16)="Directory full" 360 EM$(17)="Volume not found" @ EM$(18)="MSUS not found" 365 EM$(19)="Read verify error" @ EM$(20)="Disc full" 370 EM$(21)="Medium damaged" @ EM$(22)="Disc drive fault" 372 EM$(23)="Data type error" @ EM$(24)="Transfer aborted" 375 FSE$=CHR$ (60) @ FOR i=66 TO 72 @ FSE$=FSE$&CHR$ (i) @ NEXT i 380 FSE$=FSE$&CHR$ (120) @ FOR i=124 TO 130 @ FSE$=FSE$&CHR$ (i) @ NEXT i 390 DIM A$(9)[18],ST$(1)[9],st$(1)[8] 395 A$(0)="initialise " @ A$(1)="file header " 400 A$(2)="data " @ A$(3)="end of file " 405 A$(4)="break " @ A$(5)="error " 410 A$(6)="ACK " @ A$(7)="NAK " 415 A$(8)="file header/break " @ A$(9)="data/EOF " 420 ST$(0)="Sending" @ st$(0)="sent" @ ST$(1)="Receiving" @ st$(1)="received" 425 DIM RE$[4],PF$[18] ! End of record sequence, previous file name 430 INTEGER RE,RL,NR ! No of chars in RE$, Record length, No of records 435 RE$=CR$&LF$ @ RE=LEN (RE$) @ RL=256 @ NR=40 @ FS=RL*NR/1024 @ PF$="" 440 DIM SL$[164],OO$[7],DX$[10],FC$[23],PT$[28],BR$[8],HS$[29] 445 SL$="TIMEOUT, RETRIES, SEND-CONVERT, DEBUG, PREFIX, END-OF-LINE, " 450 SL$=SL$&"RECORD-END, FILE-SIZE, RECORD-LENGTH, NO-OF-RECORDS, " 455 SL$=SL$&"DUPLEX, LOCAL-ECHO, FLOW-CONTROL, HANDSHAKE, PARITY" 460 OO$="OFF, ON" @ DX$="FULL, HALF" @ FC$="NONE, XON/XOFF, DTR/RTS" 462 PT$="NONE, ODD, EVEN, MARK, SPACE" @ BR$="110, 300" 463 HS$="NONE, BELL, LF, CR, XON, XOFF" 465 DIM SS$[47],RS$[32] 470 SS$="SEND "&Q$&"Source filename"&Q$&" <"&Q$&"Destination filespec"&Q$&">" 475 RS$="RECEIVE <"&Q$&"Destination filespec"&Q$&">" 480 DIM IO$[14],IC$[14],IV$[13] 485 IO$="Illegal option" @ IC$="Illegal string" @ IV$="Illegal value" 490 INTEGER BR,DX,LE,FC,HS,PT,SC,ps 495 BR,DX,LE=1 @ PT=3 @ FC,SC,ps=0 @ HS=4 @ GOSUB rs_set 500 ! ******************************************************************** ! 510 ! * * ! 520 ! * COMMAND PROCESSOR SECTION * ! 530 ! * * ! 540 ! ******************************************************************** ! 550 ! # 560 ! # This section passes a parameter list to the required command in S$ 570 ! 580 ! COMMAND PROCESSOR 590 ! ----------------- 600 com_proc: GOSUB dkeys ! Set keys to jump to dummy routine 610 AWRITE 20,0 @ DISP CP$&" > Enter command ";! Display command prompt 620 RELEASE KEYBOARD ! Resort to normal keyboard operation 630 INPUT S$@ CP$=KP$ ! Input string, reset command prompt 640 TAKE KEYBOARD ! Block out keyboard again 645 AWRITE 19,0,RPT$ (" ",80) ! Blank any message from previous command 646 AWRITE 22,0,RPT$ (" ",160) ! '' '' '' '' '' '' 650 GOSUB split ! Split at fist space 660 C=FNinlist(F$,CL$) ! Is command in command list 670 IF C=0 THEN AWRITE 22,0,"Invalid command - "&F$ ! No - display 675 IF C<1 THEN 610 ! ? - re-enter 680 ON C GOSUB connect ,send_file ,rec_file ,set ,show_pars ,exit ,exit ,dir 690 GOTO com_proc 700 ! 710 ! ROUTINE TO SPLIT STRING AT FIRST SPACE OR QOUTE 720 ! ----------------------------------------------- 730 split: S$=TRIM$ (S$) ! Trim leading/trailing spaces 740 p=POS (S$,Q$) @ P=POS (S$,SP$) ! Find position of qoute & space 745 IF p*P=0 THEN P=MAX (P,p) ELSE P=MIN (P,p) ! If both find first 750 IF P=0 THEN F$=S$ @ S$="" ELSE F$=S$[1,P-1] @ S$=S$[P,LEN (S$)] 760 RETURN ! Return F$=First 'word' S$=rest 850 ! 860 ! EXIT ROUTINE 870 ! ------------ 880 exit: CLEAR @ RELEASE KEYBOARD @ ABORTIO 10 @ DISP "Kermit finished" @ END 900 ! 910 ! CATALOGUE DISK 920 ! -------------- 930 dir: ON ERROR GOSUB fserr @ f=0 ! Set error trap 935 S$=TRIM$ (S$) @ IF S$#"" THEN CAT S$ ELSE CAT ! Catalogue disk 940 IF f#0 THEN AWRITE 19,0,EM$(f) @ RETURN ! If error display message 950 FOR I=1 TO 4 @ DISP @ NEXT I @ RETURN ! Move screen up 4 lines 1000 ! ****************************************************************** ! 1010 ! * * ! 1020 ! * TERMINAL EMULATION * ! 1030 ! * * ! 1040 ! ****************************************************************** ! 1050 connect: F,f=0 ! Reset escape flag & cr flag 1070 C=0 @ START CRT AT R ! Set initial position on screen 1080 AWRITE 0,0 @ CLEAR ! Clear screen 1090 DISP "HP86 Kermit - Terminal emulation mode" @ DISP 1100 DISP "Function key Escape character Action" 1110 DISP "--------------------------------------------------" 1120 DISP " k1 C Return to KERMIT" 1130 DISP " k7 B Transmit break" 1135 DISP " k14 Enable transmit" 1140 AWRITE 23,0 ! Move cursor to first position 1150 DEL=5 ! Keyboard delay = 05 milliseconds 1160 ON KEY# 1 GOTO EXIT1 ! Set k1 to branch to an exit routine 1170 ON KEY# 7 GOSUB BREAK ! k7 transmit a break 1172 ON KEY# 14 GOSUB TX_EN ! k14 re-enable transmitter 1180 ON EOT 10 GOSUB BUFFULL ! Input buffer full routine 1190 TAKE KEYBOARD ! place all keys in buffer (except k1-14) 1200 k$=" " @ AWRITE 23,0,HGL?$ (k$,1) ! Set cursor on 1210 ! 1220 ! START OF LOOP 1230 ! ------------- 1240 START: STATUS 10,9 ; S1,S2 ! Get RS232 transmit status 1250 ! Bit 7 of S1 = Transmit enabled : Bit 5 of S2 = Transmit buffer empty 1260 ! Check transmit status if can't transmit get byte from RS232 (if there) 1270 IF BINAND (S1,128)=0 OR BINAND (S2,32)=0 THEN RSGET 1280 ! 1290 ! CHECK KEYBOARD GET KEY PRESSED 1300 ! ------------------------------ 1310 K$=KEY$ @ IF K$="" THEN RSGET ! Get key if null get byte from RS232 1320 IF F=0 THEN KOUT ELSE F=0 ! If escape not pressed last time skip 1330 IF K$=ESC$ THEN 1500 ! If escape - transmit 1340 IF K$="C" OR K$="c" THEN EXIT1 ! If C exit program 1350 IF K$="B" OR K$="b" THEN GOSUB BREAK ! If B - Break 1360 GOTO START ! Next character 1370 KOUT: IF K$=BS$ THEN K$=DEL$ ! Backspace = Delete (127) 1380 IF K$=EL$ THEN K$=CR$ @ f=HS#0 ! Endline = CR, set flag if handshake 1390 IF K$=ESC$ THEN F=1 @ BEEP @ GOTO RSGET ! Escape set flag 1400 IF K$>DEL$ THEN RSGET ! If char > 127 then ignore 1405 IF LE=0 THEN 1500 ! If no local echo transmit 1410 AWRITE 23,C,k$ ! Remove cursor 1420 IF K$ >= SP$ THEN 1450 ! If char is not ctrl char skip 1430 IF K$=CR$ THEN C=0 @ GOTO 1490 ! If <CR> then reset column count 1440 IF K$=LF$ THEN 1470 ! If <LF> then nextline 1450 AWRITE 23,C,K$ ! Display char 1460 C=C+1 @ IF C<80 THEN 1490 ELSE C=0 ! increase column count 1470 R=R+1 @ IF R=204 THEN R=0 ! next line (reset if screen end) 1480 AWRITE 24,0,RPT$ (SP$,80) @ START CRT AT R ! set screen to new line 1490 AWRITE 23,C @ AREAD k$ @ AWRITE 23,C,HGL?$ (k$,1) ! redraw cursor 1500 OUTPUT OBUFF$ USING "#,A" ; K$ ! Output char to buffer 1502 IF f THEN OUTPUT OBUFF$ USING "#,A" ; HC$ ! Output handshake character 1506 STATUS OBUFF$,1 ; S1,S,S3 ! Get buffer status 1508 IF S1=0 OR S3#0 THEN 1520 ! If buffer empty or transfer active skip 1510 TRANSFER OBUFF$ TO 10 INTR ! Output buffer to RS232 1520 WAIT DEL ! Wait to avoid multiple characters 1530 ! 1540 ! GET BYTE FROM RS232 IF AVAILABLE 1550 ! ----------------------------------- 1560 RSGET: STATUS IBUFF$,1 ; S3 ! Get no of characters in buffer 1565 IF S3=0 THEN START ! If no data in buffer - start of loop 1570 AWRITE 23,C,k$ ! Cursor off (reprint old char) 1580 ENTER IBUFF$ USING "#,#K" ; I$ ! Get string from buffer 1590 FOR I=1 TO LEN (I$) ! For no of chars 1600 K$=I$[I,I] ! Get character from buffer 1610 IF K$ >= SP$ THEN 1660 ! If char is not ctrl char skip 1620 IF K$=CR$ THEN C=0 @ GOTO 1700 ! If <CR> then reset column count 1630 IF K$=LF$ THEN 1680 ! If <LF> then nextline 1640 IF K$=BEL$ THEN BEEP @ GOTO 1700 ! If <BEL> beep 1650 GOTO 1700 ! Ignore other control characters 1660 AWRITE 23,C,K$ ! Display char 1670 C=C+1 @ IF C<80 THEN 1700 ELSE C=0 ! Increase column count 1680 R=R+1 @ IF R=204 THEN R=0 ! next line (reset if screen end) 1690 AWRITE 24,0,RPT$ (SP$,80) @ START CRT AT R ! set screen to new line 1700 NEXT I ! Next char 1710 AWRITE 23,C @ AREAD k$ @ AWRITE 23,C,HGL?$ (k$,1) ! redraw cursor 1720 GOTO START ! Return to start of loop 1730 ! 1740 ! BUFFER FULL ROUTINE 1750 ! ------------------- 1760 BUFFULL: OFF EOT 10 @ STATUS 10,11 ; S4 ! Find reason 1765 IF BINAND (S4,64)#0 THEN 1810 ! Input buffer full 1770 IF f=0 THEN 1850 ! Not CR and handshake 1780 f=0 @ STATUS 10,9 ; S@ S=BINAND (S,127) ! Mask off Transmit enable bit 1790 ABORTIO 10 @ CONTROL 10,9 ; S@ TRANSFER 10 TO IBUFF$ INTR ! Disable TX 1800 GOTO 1850 1810 ENTER IBUFF$ USING "#,#K" ; I$@ TRANSFER 10 TO IBUFF$ INTR 1820 ! Enter complete buffer and restart input 1830 DISP I$ ! Display buffer contents 1840 DISP "BUFFER FULL POSSIBLE DATA LOSS !" ! Display warning 1850 ON EOT 10 GOSUB BUFFULL @ RETURN ! Return 1860 ! 1870 ! EXIT ROUTINE 1880 ! ------------ 1890 EXIT1: ! END ALL INPUT/OUTPUT 1900 RELEASE KEYBOARD @ OFF EOT 10 @ CLEAR ! Reset 1910 RETURN ! Return 1920 ! 1930 ! TRANSMIT A BREAK 1940 ! -------------------- 1950 BREAK: REQUEST 10;8 @ RETURN ! Transmit break signal 1960 ! 1970 ! RE-ENABLE TRANSMITER 1980 ! -------------------- 1990 TX_EN: RESUME 10 @ RETURN ! Re-enable transmiter 2000 ! ***************************************************************** ! 2010 ! * * ! 2020 ! * SEND FILE - EXTRACT FILE NAME SECTION * ! 2030 ! * * ! 2040 ! ***************************************************************** ! 2050 ! # This section extracts the file names from the parameter list following 2060 ! # the SEND command . 2070 ! # S$ - contains the parameter list 2080 ! # 2160 ! 2170 ! EXTRACT FILE NAMES FROM PARAMETER LIST 2180 ! -------------------------------------- 2190 send_file: S$=TRIM$ (S$) @ DF$="" ! Strip excess blanks from parameters 2195 IF S$="?" THEN AWRITE 22,0,SS$ @ RETURN ! Display send syntax 2200 p=FNfsplit(S$) @ IF p=0 THEN errfn ! Check for "filename" 2210 SF$=TRIM$ (S$[2,p]) ! Get source filename 2220 IF l<p+2 THEN volrem ! If no dest filename convert source 2230 S$=TRIM$ (S$[p+2,l]) ! Get destination filename 2240 p=FNfsplit(S$) @ IF p=0 THEN errfn ! Check for "filename" 2250 S$=TRIM$ (S$[2,p]) @ GOTO chckfn ! Get destination filename 2260 ! 2270 ! REMOVE VOLUME OR DRIVE No FROM FILE NAME 2280 ! ---------------------------------------- 2290 volrem: S$=SF$ ! Get file name 2300 p=POS (S$,DT$) @ IF p=0 THEN p=POS (S$,CN$) ! "." - volume ":" - drive 2310 IF p>0 THEN S$=S$[1,p-1] ! Extract file name 2320 ! 2330 ! CHECK FILE NAME AND CONVERT TO A 'LEGAL' NAME 2340 ! --------------------------------------------- 2350 chckfn: l=LEN (S$) @ f=0 @ j=0 ! Get len,clear flag,reset char count 2360 S$=UPC$ (S$) ! Convert to upper case 2370 IF POS (S$,DT$) THEN 2410 ! If name contains "." skip 2380 p=POS (S$,SP$) @ IF p>0 THEN 2400 ! If name contains space convert to "." 2390 p=POS (S$,UL$) @ IF p=0 THEN 2410 ! If name does not contain "_" skip 2400 S$[p,p]=DT$ ! Convert character to "." 2410 FOR i=1 TO l @ p=POS (VC$,S$[i,i]) ! Check char with legal list 2420 IF p=0 OR p=1 AND (f=1 OR j=0 OR j=l-1) THEN 2450 ! skip if illegal 2430 IF p=1 THEN f=1 ! Set flag to ensure only one "." 2440 j=j+1 @ DF$[j,j]=S$[i,i] ! Transfer legal character to file name 2450 NEXT i 2460 IF j=0 THEN DF$=SF$ @ GOTO 2800 ! If file name illegal send source name 2470 l=LEN (DF$) @ p=POS (DF$,DT$) ! Find length of name and "." position 2480 IF p=0 THEN DF$=DF$&"." @ p=l ! If no "." add one to end of DF$ 2490 IF p=l THEN DF$=DF$&FTYP$ ! If "." at end of DF$ add default type 2600 ! ******************************************************************** ! 2610 ! * * ! 2620 ! * SEND COMMAND MAIN SECTION * ! 2630 ! * * ! 2640 ! ******************************************************************** ! 2650 ! # This section sends the file from the HP86 to the remote kermit 2660 ! # The following variables are used from previous sections 2670 ! # SF$ - The source file name 2680 ! # DF$ - The destination file name 2690 ! # Also the following parameters changed by SET (* or Y(0)) 2700 ! # Receiving Sending Meaning 2710 ! # RMAXL SMAXL * Maximum packet length 2720 ! # RTO * STO Timeout values 2730 ! # RNPAD SNPAD * Number of padding characters 2740 ! # RPADC$ SPADC$ * Pad character 2750 ! # REOL SEOL * End of line character (end of packet) 2760 ! # RQCTL$ * SQCTL$ Prefix character for control characters 2770 ! 2780 ! OPEN SOURCE FILE 2790 ! ---------------- 2800 n,pc,st,k,SNPAD=0 @ RT$="" @ sr=15 @ rr=17 ! Initialise 2805 GOSUB open_read @ IF f#0 THEN srexit ! Open file 2810 GOSUB dsend @ ON KEY# 1 GOSUB abort ! Display & set abort key 2815 ! 2820 ! SEND SEND_INIT PACKET 2830 ! --------------------- 2840 send_init: n=0 @ T$=SI$ @ T=0 @ IBUFF$="" ! seq no, set type, clear buff 2845 GOSUB init_pack @ OD$=IN$ ! Set up INIT packet data 2890 GOSUB send_pack @ IF f#0 THEN srexit ! Send SEND-INIT 2900 ! 2910 ! DECODE ACK PACKET TO GET SEND PARAMETERS 2920 ! ---------------------------------------- 2930 GOSUB dcd_init ! Decode INIT data 3010 ! 3020 ! SEND FILE HEADER 3030 ! ________________ 3040 send_head: T$=SH$ @ T=1 @ OD$=DF$ ! Set packet type & data = file name 3050 GOSUB send_pack @ IF f#0 THEN srexit ! Send packet, exit if error 3060 ! 3070 ! SEND DATA FROM FILE 3080 ! ------------------- 3090 T$=SD$ @ T=2 @ DB$="" @ e=0 @ MAXL=SMAXL-3 ! Set type and clear data buf 3100 MINL=IP (MAXL/2) @ IF MINL<1 THEN MINL=1 ! Set minimum packet length 3110 GOSUB get_data @ IF f#0 THEN RETURN ! Get data 3120 IF OD$="" THEN send_eof ! If no data send end of file 3130 GOSUB send_pack @ IF f#0 THEN srexit ! Send packet 3135 IF LEN (ID$)=0 THEN 3110 ! No term - get more data 3140 IF ID$[1,1]#"Z" AND ID$[1,1]#"X" THEN 3110 ! Get more data (unless stop) 3150 ! 3160 ! SEND END OF FILE & BREAK PACKETS 3170 ! -------------------------------- 3180 send_eof: T$=SE$ @ T=3 ! Set up type = send end of file 3190 GOSUB send_pack @ IF f#0 THEN srexit ! Send packet 3200 T$=SB$ @ T=4 @ GOSUB send_pack ! Set up type = break - send packet 3210 GOTO srexit ! Jump to exit routine 3510 ! 3520 ! REPORT FILENAME ERROR 3530 ! --------------------- 3540 errfn: CP$="Filename error" @ RETURN ! Change command prompt & return 4000 ! ****************************************************************** ! 4010 ! * * ! 4020 ! * RECEIVE COMMAND * ! 4030 ! * * ! 4040 ! ****************************************************************** ! 4050 ! 4060 ! EXTRACT FILENAME (IF SPECIFIED) 4070 ! ------------------------------- 4080 rec_file: S$=TRIM$ (S$) ! Strip leading & trailing blanks from params 4083 IF S$="?" THEN AWRITE 22,0,RS$ @ RETURN ! Display receive syntax 4085 sr=17 @ rr=15 @ st=1 @ GOSUB dsend ! Initialise display 4090 p=FNfsplit(S$) @ IF p=0 THEN ft=1 @ GOTO 4200 ! Check if filename present 4100 DF$=TRIM$ (S$[2,p]) @ ft=0 ! Get destination filename 4110 p=POS (DF$,DT$) @ IF p=0 THEN p=POS (DF$,CN$) ! Volume (.) or MSUS (:) 4120 IF p=0 THEN 4150 ! If none skip 4130 VN$=DF$[p] @ IF p=1 OR LEN (VN$)>6 THEN errfn ! Get volume name & check 4140 DF$=DF$[1,p-1] ! Get file name 4150 IF LEN (DF$)>10 THEN errfn ! Check filename 4155 AWRITE 4,2,ST$(1)&" as '"&DF$&"'" ! Display name 4160 ! 4170 ! RECEIVE SEND_INIT PACKET 4180 ! ------------------------ 4200 rec_init: n,nf,pc,k=0 @ IBUFF$="" @ ON KEY# 1 GOSUB abort 4210 GOSUB init_pack @ A$=SI$ @ T=0 ! Set INIT packet, Allowable type "S" 4220 GOSUB get_pack @ IF f#0 THEN srexit ! Get SEND-INIT 4230 GOSUB dcd_init ! Decode SEND-INIT packet 4232 ! 4234 ! RECEIVE FILE HEADER OR BREAK 4236 ! ---------------------------- 4240 rec_head: A$="FBSZ" @ DB$="" ! Valid types F/B (S/Z prev), Clear buffer 4250 T=8 @ GOSUB get_pack ! Get File header or Break packet 4260 IF RT$=SB$ OR f#0 THEN srexit ! If break received or error exit 4262 ! 4264 ! EXTRACT FILE NAME, CONVERT & OPEN FILE 4266 ! -------------------------------------- 4270 SF$=ID$ @ k=0 ! Get Fn, reset byte count 4272 IF ft=0 THEN 4330 ELSE DF$=SF$ ! Skip if dest Fn specified 4275 l=LEN (DF$) @ p=POS (DF$,DT$) ! Get len, pos of '.' 4280 IF l=0 THEN DF$=DFN$&DFT$ @ GOTO 4275 ! Default Fn & Ft 4285 IF p=0 THEN 4330 ! No '.' - no seperation 4290 IF p=l THEN DF$=DF$&DFT$ @ GOTO 4275 ! '.' at end add default Ft 4295 IF p=1 THEN DF$=DFN$&DF$ @ GOTO 4275 ! '.' at start add default Fn 4300 F$=DF$[1,p-1] @ IF LEN (F$)>6 THEN F$=F$[1,6] ! Fn - 6 chars 4310 S$=DF$[p+1,l] @ IF LEN (S$)>3 THEN S$=S$[1,3] ! Ft - 3 chars 4320 DF$=F$&SP$&S$ @ ft=LEN (F$)+1 ! Fn Ft 4330 GOSUB open_write @ IF f#0 THEN srexit ! Open file 4335 AWRITE 4,2,ST$(1)&" '"&SF$&"' as '"&DF$&"'" ! Display file names 4340 ! 4350 ! RECEIVE DATA OR END OF FILE 4360 ! --------------------------- 4370 rec_data: A$="DZF" @ T=9 ! Valid types D/Z (F prev) 4380 GOSUB get_pack @ IF f#0 THEN srexit ! Get packet 4390 IF RT$=SE$ THEN GOSUB close_write @ GOTO rec_head ! If EOF close file 4400 GOSUB put_data @ IF f#0 THEN srexit ! Store data in file 4410 GOTO rec_data ! Get next data packet 5000 ! ***************************************************************** ! 5010 ! * * ! 5020 ! * SET/SHOW COMMANDS * ! 5030 ! * * ! 5040 ! ***************************************************************** ! 5050 show_pars: IF S$="" THEN sa ! If no parameters after show - show all 5060 set: GOSUB split @ S$=TRIM$ (S$) ! Split parameter string 5070 p=FNinlist(F$,SL$) ! Find if option is in list 5080 IF p<1 THEN DF$=F$ @ I$=IO$ @ GOTO 5150 ! Illegal option 5090 I$=FNxlist$(SL$,p) ! Get real option (ie not abbrev.) 5100 IF C=5 THEN 5140 ! If show just show 5110 DF$=S$ @ O=p ! Save option setting 5115 ! Set 5120 ON p GOSUB S0 ,S1 ,S2 ,S3 ,S4 ,S5 ,S6 ,S7 ,S8 ,S9 ,S10 ,S11 ,S12 ,S13 ,S14 5130 IF p<1 THEN 5150 ELSE p=O @ S$=DF$ ! If error or ? skip else get option 5135 ! Show 5140 ON p GOSUB s0 ,s1 ,s2 ,s3 ,s4 ,s5 ,s6 ,s7 ,s8 ,s9 ,s10 ,s11 ,s12 ,s13 ,s14 5150 IF p>-1 THEN AWRITE 22,0,I$&" - "&DF$ 5160 RETURN 5500 ! ***************************************************************** ! 5510 ! * * ! 5520 ! * SET COMMAND * ! 5530 ! * * ! 5540 ! ***************************************************************** ! 5550 S0: RTO=FNpval(S$,RTO) @ RETURN ! Timeout 5560 S1: RLIM=FNpval(S$,RLIM) @ RETURN ! Retry limit 5570 S2: ps=FNlset(S$,SC,OO$) @ RETURN ! Send conversion 5580 S3: db=FNlset(S$,db,OO$) @ RETURN ! Debug (ON/OFF) 5590 S4: p=0 @ IF LEN (S$)#1 THEN I$=IC$ @ RETURN ! Prefix 5600 SQCTL$=S$ @ RETURN 5610 S5: SEOL=FNpval(S$,SEOL) @ RETURN ! End of line 5620 S6: T=0 @ DB$="" ! Record end marker 5630 GOSUB split @ k=FNpval(F$,0) ! Get no 5640 IF k=0 THEN RETURN ! If illegal return 5650 DB$=DB$&CHR$ (k) @ T=T+1 ! Add to string 5660 IF S$#"" AND T<4 THEN 5630 ! If more get no 5670 RE=T @ RE$=DB$ @ p=7 @ RETURN ! Set new value & return 5680 S7: FS=FNpval(S$,FS) @ NR=FS*1024/RL @ RETURN ! File size 5690 S8: RL=FNpval(S$,RL) @ NR=FS*1024/RL @ RETURN ! Record length 5700 S9: NR=FNpval(S$,NR) @ FS=NR*RL/1024 @ RETURN ! No of records 5710 S10: DX=FNlset(S$,DX,DX$) @ LE=DX @ GOTO 5760 ! Duplex 5720 S11: LE=FNlset(S$,LE,OO$) @ GOTO 5760 ! Local echo 5730 S12: FC=FNlset(S$,FC,FC$) @ IF FC#0 THEN HS=0 ! Flow control 5735 GOTO 5760 5740 S13: HS=FNlset(S$,HS,HS$) @ IF HS#0 THEN FC=0 ! Handshake 5745 GOTO 5760 5750 S14: PT=FNlset(S$,PT,PT$) ! Parity 5760 GOSUB rs_set @ RETURN ! Reset RS232 5770 ! 6000 ! ***************************************************************** ! 6010 ! * * ! 6020 ! * SHOW COMMAND * ! 6030 ! * * ! 6040 ! ***************************************************************** ! 6110 sa: CLEAR ! Clear screen 6120 FOR N=0 TO 14 @ n=N+1 ! For each set option 6130 AWRITE 2+N DIV 2,40*(N MOD 2),FNxlist$(SL$,n) ! Display option 6140 ON n GOSUB s0 ,s1 ,s2 ,s3 ,s4 ,s5 ,s6 ,s7 ,s8 ,s9 ,s10 ,s11 ,s12 ,s13 ,s14 6150 AWRITE 2+N DIV 2,15+40*(N MOD 2),DF$ ! Display value 6160 NEXT N 6170 RETURN 6200 s0: DF$=VAL$ (RTO) @ RETURN ! Timeout 6210 s1: DF$=VAL$ (RLIM) @ RETURN ! Retry limit 6220 s2: DF$=FNxlist$(OO$,SC+1) @ RETURN ! Send conversion 6230 s3: DF$=FNxlist$(OO$,db+1) @ RETURN ! Debug 6240 s4: DF$=SQCTL$ @ RETURN ! Prefix 6250 s5: DF$=VAL$ (SEOL) @ RETURN ! End of line 6260 s6: DF$="" ! Record end marker 6262 FOR I=1 TO RE @ DF$=DF$&VAL$ (NUM (RE$[I,I]))&SP$ @ NEXT I 6265 RETURN 6270 s7: DF$=VAL$ (FS)&"k" @ RETURN ! File size 6280 s8: DF$=VAL$ (RL) @ RETURN ! Record length 6290 s9: DF$=VAL$ (NR) @ RETURN ! No of records 6300 s10: DF$=FNxlist$(DX$,DX+1) @ RETURN ! Duplex 6310 s11: DF$=FNxlist$(OO$,LE+1) @ RETURN ! Local echo 6320 s12: DF$=FNxlist$(FC$,FC+1) @ RETURN ! Flow control 6330 s13: DF$=FNxlist$(HS$,HS+1) @ RETURN ! Handshake 6340 s14: DF$=FNxlist$(PT$,PT+1) @ RETURN ! Parity 10000 ! ***************************************************************** ! 10010 ! * * ! 10020 ! * SEND & RECEIVE SUBROUTINES * ! 10030 ! * * ! 10040 ! ***************************************************************** ! 10050 ! 10060 ! RECEIVE PACKET 10070 ! -------------- 10080 rec_pack: m=0 @ ID$="" ! Reset mark flag 10090 ON TIMER# 1,TMO GOTO rto ! Set timeout limit 10100 b_chk: STATUS IBUFF$,1 ; S ! Get buffer status 10105 K$=KEY$ @ IF K$#"" THEN rto ! If key pressed treat like timeout 10110 IF S=0 THEN WAIT TMO/5 @ GOTO b_chk ! If no data wait & check again 10120 ENTER IBUFF$ USING "#,#K" ; I$ ! Get buffers contents 10130 l=LEN (I$) @ i=1 ! Data length & count 10140 n_chr: k$=I$[i,i] ! Get character 10145 IF k$=MK$ THEN m=1 @ RP$="" @ j=0 ! If mark set flag, null packet etc 10150 IF m=0 THEN i_chr ! Mark not reached yet skip 10160 IF k$=REOL$ THEN e_pck ! End line recieved 10170 RP$=RP$&k$ @ j=j+1 ! Add char to packet inc count 10180 i_chr: i=i+1 @ IF i>l THEN b_chk ELSE n_chr ! if no data in buf get more 10190 e_pck: IF j<5 THEN 10100 ! packet not long enough get another 10200 OFF TIMER# 1 ! Halt timer 10210 IF i<l THEN IBUFF$=I$[i+1,l]&IBUFF$ ! If data in I$ replace in buffer 10220 IF db=1 THEN AWRITE rr,rc,RP$ ! display packet if debug on 10230 c$=FNcbyte$(RP$[2,j-1]) ! Calculate check byte | if wrong 10240 IF c$#RP$[j,j] THEN RT$=FNstbit$(RP$[j]) @ bp=bp+1 @ RETURN ! set B7 type 10250 RT$=RP$[4,4] @ rn=FNunchar(RP$[3,3]) ! Get type & sequence number 10260 f=0 @ FOR i=5 TO j-1 @ k$=RP$[i,i] ! Get each charcter in data part 10270 IF f=0 THEN 10300 ! If prefix flag off skip 10280 IF k$#RQCTL$ THEN k$=FNctl$(k$) ! If not prefix char change to ctrl 10290 f=0 @ GOTO 10310 ! Skip to add to data string 10300 IF k$=RQCTL$ THEN f=1 @ GOTO 10320 ! If prefix char set flag next char 10310 ID$=ID$&k$ ! Add char to data string 10320 NEXT i @ RETURN ! Return 10330 rto: OFF TIMER# 1 ! Disable timer 10333 IF m=1 THEN m=2 @ GOTO 10090 ! Packet is being transmitted wait 10335 IF HS#0 THEN RESUME 10 ! If handshake enable transmit 10338 tmo=tmo+1 @ RT$="T" @ RETURN ! Timeout type = "T" 10340 ! 10350 ! SEND PACKET 10360 ! ----------- 10370 send_pack: f=0 @ r=0 @ GOSUB c_pack ! Set flag & retry, construct packet 10380 send1: s=T @ GOSUB disp_state ! Display state 10390 IF db THEN AWRITE sr,0,RPT$ (SP$,320) @ AWRITE sr,sc,OP$ ! debug display 10400 GOSUB send_buff @ IF f#0 THEN RETURN ! Send buffer out 10410 s=6 @ GOSUB disp_state @ GOSUB rec_pack ! Display, receive ACK/NAK 10415 IF RT$>DEL$ OR RT$=TM$ THEN 10450 ! Bad packet or timeout retry ? 10420 N=BINAND (rn-BINAND (n,63),63) @ f=0 ! Find seq no difference 10430 IF RT$=AK$ AND N=0 OR RT$=NK$ AND N=1 THEN pc,n=n+1 @ RETURN ! Ok return 10435 IF RT$=AK$ AND N=63 THEN 10410 ! Previous ACK - Ignore 10440 IF RT$#NK$ THEN f=4 @ RETURN ELSE nk=nk+1 ! If not nak - wrong packet 10450 r=r+1 @ IF r<RLIM THEN send1 ! If retry < limit send again 10460 IF RT$=TM$ THEN f=1 @ RETURN ! Timeout error 10470 IF RT$=NK$ THEN f=2 ELSE f=3 ! NAK error 10480 RETURN 10510 ! 10520 ! CONSTRUCT PACKET 10530 ! ---------------- 10540 c_pack: OP$=FNchar$(BINAND (n,63))&T$&OD$ ! Add seq & type to data 10550 OP$=FNchar$(LEN (OP$)+1)&OP$ ! Add length to data 10560 OP$=MK$&OP$&FNcbyte$(OP$) ! Add mark & check byte 10570 IF SNPAD>0 THEN OBUFF$=RPT$ (SPADC$,SNPAD) ! Add padding if needed 10580 OUTPUT OBUFF$ USING "#,K" ; OP$&CHR$ (SEOL) ! Output to buffer 10585 IF HS#0 THEN OUTPUT OBUFF$ USING "#,A" ; HC$ ! Output handshake 10590 STATUS OBUFF$,1 ; bl@ RETURN ! Get buffer length 10600 ! 10610 ! TRANSMIT BUFFER CONTENTS 10620 send_buff: ! ------------------------ 10630 ON TIMER# 1,STM GOTO 10690 ! Set time limit for transfer 10640 CONTROL OBUFF$,1 ; bl ! Reset buffer fill pointer 10650 TRANSFER OBUFF$ TO 10 INTR ! Transfer buffer to RS232 10660 STATUS OBUFF$,1 ; S ! Get buffer status 10670 IF S>0 THEN 10660 ! Loop until buffer empty (ie all sent) 10673 IF HS=0 THEN 10680 ! Skip if no handshake 10675 STATUS 10,9 ; S@ S=BINAND (S,127) ! Clear bit 7 reg 9 (transmit disable) 10678 ABORTIO 10 @ CONTROL 10,9 ; S@ TRANSFER 10 TO IBUFF$ INTR 10680 OFF TIMER# 1 @ IBUFF$="" ! Disable timer & clear input buffer 10685 RETURN 10690 f=5 @ OFF TIMER# 1 @ RETURN ! Set error flag 10700 ! 10710 ! RECEIVE PACKET WITH ACK 10720 ! ----------------------- 10730 get_pack: r=0 10740 s=T @ GOSUB disp_state @ AWRITE rr,0,RPT$ (SP$,320) ! Display 10745 f,p=0 @ GOSUB rec_pack ! Receive packet 10750 IF RT$=TM$ THEN f=1 @ GOTO 10830 ! If timeout retry ? 10760 IF RT$>DEL$ THEN f=3 @ GOTO 10830 ! If checksum error retry 10770 p=POS (A$,RT$) @ N=BINAND (rn-n,63) ! Is received type valid 10780 IF N#0 AND N#63 OR p=0 THEN f=4 @ RETURN ! If not valid exit 10790 OD$="" @ IF RT$=SI$ THEN OD$=IN$ ! If SEND-INIT set INIT ACK 10800 T$=AK$ @ s=6 @ n=rn @ GOSUB c_pack ! Construct ACK 10810 n=(n+1) MOD 64 @ GOTO 10850 ! Get next seq - Send ACK 10830 r=r+1 @ IF r>RLIM THEN RETURN ! If retry limit exceeded exit 10840 T$=NK$ @ s=7 @ OD$="" @ nk=nk+1 @ GOSUB c_pack ! Construct NAK 10850 GOSUB disp_state @ IF db THEN AWRITE sr,sc,OP$ ! Display state 10860 f=0 @ GOSUB send_buff @ IF f#0 THEN RETURN ! Send ACK/NAK 10870 IF p#1 AND p#2 OR N#0 THEN 10740 ! If not valid get another packet 10880 pc=pc+1 @ RETURN ! Inc packet count - return 11000 ! ***************************************************************** ! 11010 ! * * ! 11020 ! * CONSTRUCT & DECODE INITIALISATION PACKETS * ! 11030 ! * * ! 11040 ! ***************************************************************** ! 11050 ! 11060 ! SET UP SEND-INIT PACKET (S(0),Y(0)) 11070 ! ----------------------------------- 11080 init_pack: tmo,nk,bp=0 ! Timeouts naks & bad packets 11090 TMO=RTO*1000 ! Set timeout for receiving 11100 IN$=FNchar$(RMAXL) ! Packet = maximum length 11110 IN$=IN$&FNchar$(STO) ! + send timeout 11120 IN$=IN$&FNchar$(RNPAD)&FNctl$(RPADC$) ! + no of pad chars & char 11130 IN$=IN$&FNchar$(SEOL)&SQCTL$ ! + end of line & ctrl qoute 11140 SMAXL=80 @ SNPAD=0 @ SPADC$=NULL$ @ REOL=13 @ RQCTL$="#" ! Defaults 11150 RETURN 11160 ! 11170 ! EXTRACT PARAMETERS FROM INIT PACKET (S(0),Y(0)) 11180 ! ----------------------------------------------- 11190 dcd_init: l=LEN (RP$)-5 @ IF l=0 THEN RETURN ! If no params return 11200 IF l<7 THEN ON l GOTO maxl ,tmo ,npad ,padc ,elc ,qctl ! Change params 11210 qctl: IF RP$[10,10]#SP$ THEN RQCTL$=RP$[10,10] ! Prefix char 11220 elc: IF RP$[9,9]#SP$ THEN SEOL=FNunchar(RP$[9,9]) ! End of line 11230 padc: IF RP$[8,8]#SP$ THEN SPADC$=FNctl$(RP$[8,8]) ! Pad character 11240 npad: IF RP$[7,7]#SP$ THEN SNPAD=FNunchar(RP$[7,7]) ! No of pad chars 11250 tmo: IF RP$[6,6]#SP$ THEN RTO=FNunchar(RP$[6,6]) ! Receive timeout 11260 maxl: IF RP$[5,5]#SP$ THEN SMAXL=FNunchar(RP$[5,5]) ! Max packet length 11270 RETURN 12000 ! 12010 ! EXIT ROUTINE FOR SEND & RECEIVE 12020 ! ------------------------------- 12030 srexit: IF f=0 OR f=5 THEN 12080 ! If ok or send problem skip 12040 IF f#4 OR RT$#ER$ THEN 12060 ! If not error packet skip 12050 AWRITE 19,0,"Error message from remote - "&ID$ @ RETURN ! Display 12060 OD$=EM$(f) @ T$=ER$ @ T=5 ! Set up error packet 12070 GOSUB c_pack @ GOSUB send_buff ! Construct and send error packet 12080 AWRITE 19,0,EM$(f) ! Display message (ok or error) 12082 BEEP (f#1)*20+20,200 ! Beep (lower for error) 12085 IF f>6 AND f<23 THEN AWRITE 19,LEN (EM$(f))+1,"(error no - "&VAL$ (e)&")" 12090 RETURN ! Return to command section 12100 ! 12110 ! ABORT TRANSFER 12120 ! -------------- 12130 abort: f=24 @ RETURN ! Set error flag to abort 20000 ! **************************************************************** ! 20010 ! * * ! 20020 ! * FUNCTIONS FOR CODING & DECODING PACKETS * ! 20030 ! * * ! 20040 ! **************************************************************** ! 20050 ! 20060 ! CONVERT NUMBER TO PRINTABLE CHARACTER 20070 ! ------------------------------------- 20080 DEF FNchar$(n) = CHR$ (n+32) ! Character = no + 32 20090 ! 20100 ! CONVERT CHARACTER TO NUMBER 20110 ! --------------------------- 20120 DEF FNunchar(c$[1]) = NUM (c$)-32 ! no = char - 32 20130 ! 20140 ! SWAP BETWEEN CONTROL CHARACTER AND PRINTABLE CHARACTER 20150 ! ------------------------------------------------------ 20160 DEF FNctl$(c$[1]) = CHR$ (BINEOR (NUM (c$),64)) ! xor bit 6 20170 ! 20180 ! SET / RESET TOP BYTE OF CHARACTER 20190 ! --------------------------------- 20200 DEF FNstbit$(c$[1]) = CHR$ (BINEOR (NUM (c$),128)) ! xor bit 7 20210 ! 20220 ! CALCULATE CHECK BYTE 20230 ! -------------------- 20240 DEF FNcbyte$(S$[96]) 20250 t=0 @ l=LEN (S$) @ FOR i=1 TO l @ t=t+NUM (S$[i,i]) @ NEXT i ! sum S$ 20260 FNcbyte$=FNchar$(BINAND (t+BINAND (t,192)/64,63)) ! Fold bits 7 & 8 20270 FN END 30000 ! ******************************************************************** ! 30010 ! * * ! 30020 ! * ROUTINES FOR DISPLAYING CURRENT SENDING STATE * ! 30030 ! * * ! 30040 ! ******************************************************************** ! 30050 ! # The following variables are used by these routines 30060 ! # S - State (0/1) sending or waiting for ACK 30070 ! # T - Type of packet being sent (0-S,1-F,2-D,3-Z,4-B) 30080 ! # n - Current sequence number (not modulo 64) 30090 ! # r - No of retries for current packet 30100 ! # nk - No of NAKs received 30110 ! # tm - No of timeouts 30120 ! # bp - No of corrupted packets received 30130 ! # k - No of bytes sent 30140 ! # SF$ - Source file specifier 30150 ! # DF$ - Destination '' '' 30260 ! 30270 ! SET UP SCREEN FOR SEND DISPLAY 30280 ! ------------------------------ 30290 dsend: CLEAR 30300 AWRITE 1,2,"HP86 Kermit - "&ST$(st)&" file" 30310 AWRITE 2,2,RPT$ ("-",LEN (ST$(st))+19) 30320 IF st=0 THEN AWRITE 4,2,ST$(st)&" "&SF$&" as "&DF$ 30330 AWRITE 6,2,"Current action :" @ AWRITE 6,46,"Retries :" 30340 AWRITE 8,2,"Packets :" @ AWRITE 8,40,"NAKs :" 30350 AWRITE 9,2,"Bytes :" @ AWRITE 9,40,"Timeouts :" 30360 AWRITE 10,40,"Bad packets :" 30370 AWRITE 8,10,st$(st) @ AWRITE 8,45,st$(1-st) @ AWRITE 9,8,st$(st) 30380 RETURN 30390 ! 30400 ! DISPLAY SENDING STATE 30410 ! --------------------- 30420 disp_state: t=s>7 OR s=6 AND st=0 OR s=0 AND st=1 ! Wait or Send (1/0) 30425 IF t THEN D$="Wait for " ELSE D$="Send " 30427 AWRITE 6,18,RPT$ (SP$,26) ! Clear old action 30430 AWRITE 6,18,D$&A$(s) @ AWRITE 6,56,VAL$ (r) ! Display action & Retries 30440 AWRITE 8,21,VAL$ (pc) @ AWRITE 8,56,VAL$ (nk) ! Packets & NAKs 30450 AWRITE 9,21,FNkb$(k) @ AWRITE 9,56,VAL$ (tmo) ! Bytes & timeouts 30460 AWRITE 10,56,VAL$ (bp) ! Bad packets received 30470 RETURN 30500 DEF FNkb$(k) = VAL$ (IP (k/102.4)/10)&"k " 40000 ! **************************************************************** ! 40010 ! * * ! 40020 ! * SUBROUTINES FOR DISK ACCESS * ! 40030 ! * * ! 40040 ! **************************************************************** ! 40050 ! 40060 ! OPEN FILE FOR READING 40070 ! --------------------- 40080 open_read: ON ERROR GOTO fserr @ ASSIGN# 1 TO SF$ ! Try to open file 40090 OFF ERROR @ f=0 @ RETURN ! If success return 40180 ! 40190 ! GET PACKET OF DATA FROM FILE 40200 ! ---------------------------- 40210 get_data: b=0 @ ON ERROR GOTO 40380 ! Set 8-bit data flag 40220 l=LEN (DB$) @ IF l>= MINL THEN 40330 ! If enough data output 40230 t=TYP (1) @ IF t#3 THEN 40250 ! Not EOF get more data 40240 e=1 @ OFF ERROR ! Error trap off 40245 IF l=0 THEN OD$="" @ RETURN ELSE 40335 ! Get any data left 40250 IF t=1 THEN 40320 ! If number skip 40260 READ# 1 ; S$@ S$=S$&RE$ @ L=LEN (S$) @ k=k+L ! Read string variable 40270 FOR i=1 TO L @ k$=S$[i,i] ! Get character 40280 IF k$ <= DEL$ THEN 40300 ELSE k$=FNstbit$(k$) ! If 8-bit reset b7 40290 IF b=0 THEN DISP "Eight bit data" @ BEEP @ b=1 ! Warn if first 8-bit 40300 IF k$<SP$ THEN DB$=DB$&SQCTL$ @ k$=FNctl$(k$) ! If ctrl prefix 40305 IF k$=SQCTL$ THEN DB$=DB$&k$ ! If prefix prefix 40310 DB$=DB$&k$ @ NEXT i @ GOTO 40220 ! Add char to buffer 40320 IF SC=0 THEN f=23 @ RETURN ! If no conversion - error 40323 READ# 1,S @ S$=VAL$ (S) ! Convert no to string 40325 DB$=DB$&SP$&S$ @ k=k+LEN (S$)+1 @ GOTO 40220 ! Add no to buffer 40330 OFF ERROR ! Stop error trap 40335 IF l<= MAXL THEN OD$=DB$ @ DB$="" @ RETURN ! If amount<max output 40340 S=MAXL ! Get split position 40350 IF DB$[S,S]=SQCTL$ THEN S=S-1 @ GOTO 40350 ! If prefix move split 40360 OD$=DB$[1,S] @ DB$=DB$[S+1,l] ! Split data save rest 40370 RETURN 40380 OFF ERROR @ IF ERRN =71 OR ERRN =72 THEN 40240 ! End of file 40390 IF ERRN =33 THEN f=23 @ RETURN ! Data type error 40400 GOTO fserr ! Goto error routine 40500 ! 40510 ! CREATE & OPEN FILE FOR WRITING 40520 ! ------------------------------ 40530 open_write: f=0 ! Set error flag 40540 IF DF$#PF$ THEN nf=0 @ GOTO 40560 ! If new name reset count skip 40550 IF nf>99 THEN f=6 @ RETURN ! If cannot renumber -exit 40555 DF$=FNnofile$(DF$) ! Renumber file 40560 ON ERROR GOTO fserr ! Set filing system error trap 40570 CREATE DF$,NR,RL ! Try to create file 40580 ASSIGN# 1 TO DF$ ! If successfull open file 40585 OFF ERROR @ PF$=DF$ ! Save name 40590 RETURN 40600 ! 40610 ! WRITE DATA TO FILE 40620 ! ------------------ 40630 put_data: DB$=DB$&ID$ @ k=k+LEN (ID$) ! Place data in buffer 40635 ON ERROR GOTO fserr ! Set error trap 40640 p=POS (DB$,RE$) ! Find end of record 40645 IF p=0 THEN OFF ERROR @ RETURN ! IF no EOR exit 40650 IF p>1 THEN S$=DB$[1,p-1] ELSE S$="" ! If data before EOR get it 40660 PRINT# 1 ; S$ @ l=LEN (DB$) ! Output to disk, find buff length 40670 IF l>p+(RE-1) THEN DB$=DB$[p+RE] ELSE DB$="" ! If any data left save 40680 GOTO 40640 40700 ! 40710 ! CLOSE FILE 40720 ! ---------- 40730 close_write: ON ERROR GOTO fserr ! Set up error trap 40740 IF LEN (DB$)>0 THEN PRINT# 1 ; DB$ @ DB$="" ! Write any remaining data 40750 ASSIGN# 1 TO * ! Close file 40760 OFF ERROR 40770 RETURN 41000 ! 41010 ! FILING SYSTEM ERROR HANDLING ROUTINE 41020 ! ------------------------------------ 41030 fserr: e=ERRN @ l=ERRL @ OFF ERROR ! Get error no & line no 41040 IF e=63 AND l=40570 THEN 40550 ! If DUP NAME & CREATE -retry new name 41050 p=POS (FSE$,CHR$ (e)) ! Find pos of error in valid string 41060 IF p>0 THEN f=6+p @ RETURN ! If valid error - set falg & return 41070 RELEASE KEYBOARD @ DISP "UNEXPECTED ERROR !" 41080 DISP USING "6A,K,9A,K" ; "ERROR ",e," AT LINE ",l @ END 42000 ! 42010 ! FUNCTION TO RENUMBER FILE 42020 ! ------------------------- 42030 DEF FNnofile$(F$) 42040 IF nf>0 THEN 42120 ! If Not first numbering skip 42080 IF ft<2 THEN 42110 ! If Not Fn Ft format skip 42090 np,p=ft @ IF np>5 THEN np=5 ! Find position of Ft 42100 F$[np]="00"&F$[p] @ GOTO 42130 ! Insert 00 42110 np=LEN (F$)+1 @ IF np>9 THEN np=9 ! Find position of no 42120 F$[np,np+1]=VAL$ (nf DIV 10)&VAL$ (nf MOD 10) 42130 nf=nf+1 @ FNnofile$=F$ ! Inc count return new name 42140 FN END 50000 ! **************************************************************** ! 50001 ! * * ! 50002 ! * MISCELANEOUS SUBROUTINES * ! 50003 ! * * ! 50004 ! **************************************************************** ! 50005 ! 50010 ! SET UP RS232 INTERFACE 50015 ! ---------------------- 50020 rs_set: ABORTIO 10 ! Halt RS232 transfer 50025 IF BR=0 THEN S=2 ELSE S=6 ! Set baud to 110 or 300 50030 CONTROL 10,3 ; S ! Set baud rate 50035 IF PT=0 THEN S=3 ELSE S=2+((PT-1)*2+1)*8 50040 CONTROL 10,4 ; S ! Set parity (7 bits or 8 if no parity) 50045 IF FC=2 THEN S=48 ELSE S=0 50050 CONTROL 10,5 ; S ! Set flow control if DTR/RTS 50055 IF FC=1 OR HS#0 THEN S=128+64*(FC=1) ELSE S=0 50060 CONTROL 10,11 ; S ! Set XON(/XOFF) if required 50065 IF FC=2 THEN S=128 ELSE S=0 50070 CONTROL 10,16 ; S ! Set auto RTS enable if required 50075 IF HS#0 THEN S=4+HS*3+(HS=4) @ HC$=CHR$ (S) ELSE S=17 50080 CONTROL 10,15 ; S ! XON or handshake char (transmit enable) 50085 ! 50090 CONTROL 10,9 ; 225 ! Strip nulls & bs & enable 50100 CONTROL 10,14 ; 19 ! XOFF character 50110 ! 50120 IOBUFFER IBUFF$ ! Set up input buffer 50130 IOBUFFER OBUFF$ ! Set up output buffer 50140 TRANSFER 10 TO IBUFF$ INTR ! Start input from RS232 interface 50145 RETURN 50150 ! 50160 ! DUMMY SUBROUTINE 50170 ! ---------------- 50180 dummy: RETURN 50190 ! 50200 ! SET UP KEYS TO DUMMY ROUTINE 50210 ! ---------------------------- 50220 dkeys: FOR i=1 TO 14 @ ON KEY# i GOSUB dummy @ NEXT i @ RETURN 50500 ! 50510 ! FUNCTION TO CHECK FOR "c..." 50520 ! ---------------------------- 50530 DEF FNfsplit(F$[80]) 50540 p=0 @ l=LEN (F$) ! Set p get length of string 50545 IF l<3 THEN 50570 ! Must be at least "?" (? - any char) 50550 IF F$[1,1]#Q$ THEN 50570 ! Must start with " 50560 p=POS (F$[2],Q$) @ IF p<2 THEN p=0 ! Find position of next " ("" invalid) 50570 FNfsplit=p ! Return position 50580 FN END 51000 ! 51001 ! FIND POSITION OF OPTION IN LIST OF VALID OPTIONS 51002 ! ------------------------------------------------ 51010 DEF FNinlist(c$,l$[195]) 51020 c$=UPC$ (c$) @ l,j=1 @ L=LEN (l$) ! c$ - uppercase, set count etc 51030 IF c$#"?" THEN 51100 ! If not '?' skip 51040 j=-1 @ IF L<68 THEN P=L @ GOTO 51070 ! If list fits display 51045 AWRITE 22,0,RPT$ (SP$,160) ! Clear screen area 51050 p=POS (l$[l],", ") ! Find ', ' 51055 IF p=0 THEN P=L @ GOTO 51070 ! If end skip 51060 l=l+p @ IF l<68 THEN P=l-1 @ GOTO 51045 ! If fits get next 51070 AWRITE 22,0,"Options :- "&l$[1,P] @ IF P=L THEN 51150 ! display 51080 l$=l$[P+2] @ L=L-P-1 @ l=1 51085 AWRITE 23,0,"Press any key for more" ! 51090 k$=KEY$ @ IF k$="" THEN 51090 ELSE 51045 ! wait for key 51100 cp=POS (l$[l],",") ! Find pos of ',' 51110 IF cp>0 THEN cp=cp+l-1 ELSE cp=L ! Adjust - if at end pos = end 51120 p=POS (l$[l,cp],c$) @ IF p=1 THEN 51150 ! Is c$ same as part of option 51130 j=j+1 @ l=cp+2 @ IF l<L THEN 51100 ! Find next option 51140 j=0 ! If no more illegal option 51150 FNinlist=j 51160 FN END 51200 ! 51210 ! FUNCTION TO CONVERT STRING TO NO 51220 ! -------------------------------- 51230 DEF FNpval(c$,o) 51240 IF c$#"?" THEN 51270 ! If not ? get value 51250 DF$="value" @ p=0 ! On return OPTION - value will be printed 51260 GOTO 51300 51270 c=NUM (c$) ! Check for numeric (0-9) 51280 IF c<48 OR c>58 THEN I$=IV$ @ p=0 @ GOTO 51300 ! Illegal value ? 51290 o=VAL (c$) ! Set new value 51300 FNpval=o ! Return value (If error then old value returned) 51310 FN END 51400 ! 51410 ! SET VARIABLE FROM LIST 51420 ! ---------------------- 51430 DEF FNlset(c$,o,l$[183]) 51440 p=FNinlist(c$,l$) @ IF p<1 THEN I$=IO$ ELSE o=p-1 51450 FNlset=o @ FN END 52000 ! 52010 ! DISPLAY OPTION FROM LIST 52020 ! ------------------------ 52030 DEF FNxlist$(l$[183],p) 52040 j=1 @ l=1 @ L=LEN (l$) ! Set count, last pos & length 52050 cp=POS (l$[l],", ") ! Position of ', ' 52060 IF cp>0 THEN cp=cp+l-2 ELSE cp=L ! Set cp to end of option 52070 IF j=p THEN FNxlist$=l$[l,cp] @ GOTO 52100 ! If position get option 52080 j=j+1 @ l=cp+3 @ IF l<L THEN 52050 ! Get next option 52090 FNxlist$="" ! If end of list return null 52100 FN END